--
-- riot/Riot/Event.hs
-- 
-- Copyright (c) Tuomo Valkonen 2004-2006.
--
-- This program is free software; you can redistribute it and/or modify
-- it under the terms of the GNU General Public License as published by
-- the Free Software Foundation; either version 2 of the License, or
-- (at your option) any later version.
--

module Riot.Event(
    event_loop,
    -- Event handlers
    e_vscroll, e_hscroll, e_pgdn, e_pgup, e_eob, e_bob,
    e_selectentry, e_nextentry, e_preventry, 
    e_pgdnentry, e_pgupentry, e_firstentry, e_lastentry,
    e_actentry, e_delentry, e_editentry, e_collapse,
    e_quit, e_refresh, e_none, e_submap, e_fallback,
    e_newentry, e_newunder, e_undo, e_redo,
    e_tag, e_clear_tags, e_delete_tagged,
    e_move_tagged_after, e_move_tagged_before, e_move_tagged_under, 
    e_save, e_help, e_quit_help, e_help_up, e_help_down,
    e_clear_message
) where

import qualified UI.HSCurses.Curses as Curses
import qualified UI.HSCurses.CursesHelper as CursesH

import qualified Control.Exception
import Time(getClockTime, toCalendarTime, CalendarTime)
import System.Posix.IO (setFdOption, FdOption(..))
import Control.Monad(liftM, when)
import Maybe
import List(init, intersperse)
import Char

import Riot.Style(UIAttr(..), init_uiattr, default_uiattr, StyleSpec)
import Riot.UI
import Riot.Entry
import Riot.Riot
import Riot.Query
import Riot.Locale

import qualified Riot.Editor as Editor
import qualified Riot.KeyMap as KeyMap


-- Edit {{{

unmodified_or_empty :: String -> String -> Bool
unmodified_or_empty n o =
    n == o || (dropWhile isSpace n == [])


do_modify :: EditableEntry a => 
             EntryTree a -> Loc -> (String, CalendarTime) -> RI a ()
do_modify ent loc (newtext, tm) = do
    newent <- entry_set_text ent newtext tm
    mod_status (\s -> let ss = snapshot s
                          et = entrytree_replace (entries s) loc newent
                          pos = find_viewlist_pos et loc
                      in check_everything $ ss{entries = et, 
                                               active_entry = Just pos,
                                               selected_entry = pos})


do_edit :: Entry e => 
    String 
    -> ((String, CalendarTime) -> RI e ELCont)
    -> RI e ELCont
do_edit text cont = do
    (m, v) <- liftIO $ CursesH.withCursor Curses.CursorVisible $ do
        Curses.endWin
        text_ <- to_locale text
        newtext_ <- Editor.edittext text_
        newtext <- from_locale newtext_
        t <- toCalendarTime =<< getClockTime
        Curses.clearOk True
        Curses.refresh
        setFdOption 0 NonBlockingRead False
        return (unmodified_or_empty newtext_ text_, (newtext, t))
    mod_status_io get_size -- Update size information
    if m then
        do_except (Control.Exception.ErrorCall 
	           "Aborted unmodified or empty entry.")
      else
        cont v

do_insert :: Entry a => Status a -> InsertWhere -> EntryTree a -> Status a
do_insert s insw ent =
    check_everything $ ss{entries = et, 
                          active_entry = Just pos,
                          selected_entry=pos}
    where
        ss = snapshot s
        (et_, loc) = entrytree_insert (entries s) insw [ent]
        et = case loc of
                 Loc (_:[]) -> et_
                 Loc ll -> fromMaybe et_ $ entrytree_expand et_ $ Loc (List.init ll)
        pos = find_viewlist_pos et loc

do_editentry :: EditableEntry a => Int -> RI a ELCont
do_editentry e = do
    (loc, ent) <- with_status (\s -> fromJust $ lnth e (entries_viewlist s))
    do_edit (entry_text ent) $ \new -> do
        do_modify ent loc new
	cont_refresh

do_newentry :: Entry a => InsertWhere -> RI a ELCont
do_newentry insw =
    do_edit "" $ \(text, tm) -> do
        status <- get_status
        e <- new_callback status text tm
        mod_status (\s -> do_insert s insw $ new_entrytree e)
        cont_refresh


-- }}}


-- Undo/redo/save {{{


use_snapshot :: Entry a => 
    Status a -> UndoInfo a -> [UndoInfo a] -> [UndoInfo a] -> Status a
use_snapshot s (UndoInfo sel act unsaved et) ub rb =
    check_entryarea $ s{
        undo_buffer = ub,
        redo_buffer = rb,
        entries = et,
        selected_entry = sel,
        active_entry = act,
        textarea_vscroll = 0,
        textarea_hscroll = 0,
        unsaved_changes = unsaved
    }

mark_saved :: Entry a => Status a -> Status a
mark_saved s =
    s{
        unsaved_changes = False,
        undo_buffer = map set_unsaved (undo_buffer s),
        redo_buffer = map set_unsaved (redo_buffer s)
    }
    where
        set_unsaved u = u{undo_unsaved_changes = True}

undo :: Entry a => Status a -> Status a
undo s =
    case undo_buffer s of 
        [] -> s
        (su:ss) -> use_snapshot s su ss ((mk_snapshot s):(redo_buffer s))


redo :: Entry a => Status a -> Status a
redo s =
    case redo_buffer s of 
        [] -> s
        (sr:ss) -> use_snapshot s sr ((mk_snapshot s):(undo_buffer s)) ss

do_save :: Entry a => String -> RI a ()
do_save fname = do 
    status <- get_status
    (save_callback status) fname (entries status)
    mod_status mark_saved

save :: Entry a => RI a ()
save = do
    status <- get_status
    case entries_fname status of
        Nothing -> error "No file name set."
        Just fname -> do_save fname

-- }}}


-- Event handling {{{

-- Generic stuff

cont_refresh :: Entry a => RI a ELCont
cont_refresh = do
    refresh 
    cont


e_quit :: Entry a => RI a ELCont
e_quit = do
    b <- with_status unsaved_changes
    if b 
         then yesno "Save changes before quitting?" (save >> nocont) nocont
         else nocont

e_refresh :: Entry a => RI a ELCont
e_refresh = cont_refresh

e_none :: Entry a => RI a ELCont
e_none = cont

e_submap :: EditableEntry a => [Curses.Key] -> KeyMap -> RI a ELCont
e_submap keys submap = do
    with_status_io draw_submap
    k <- get_key refresh_fn       
    if KeyMap.isAbort k
       then do with_status_io clear_message
               cont
       else do c <- get_key_handler2 keys submap k 
               case c of
                 ELCont Untouched -> with_status_io clear_message
                 _ -> return ()
               return c
    where
        draw_submap s = do
            message s ("[" ++ KeyMap.keylist2str keys ++ "-]")
        refresh_fn = do redraw 
                        with_status_io draw_submap 


e_fallback :: EditableEntry a => [Curses.Key] -> KeyMap 
           -> Curses.Key -> RI a ELCont
-- Check if control is set and call handle_key again with the plain key.
e_fallback keys keyMap (Curses.KeyChar k)
     | ord '\^A' <= ord k && ord k <= ord '\^Z' =
         get_key_handler2 keys keyMap 
           (Curses.KeyChar $ chr $ ord k - ord '\^A' + ord 'a')
e_fallback keys _  _ = do
    with_status_io (\s -> message s ("Key is not bound: " ++ 
                                     KeyMap.keylist2str keys))
    cont_clr

goto_next_or_redraw :: Entry a => RI a ELCont
goto_next_or_redraw = do
    status <- get_status
    if (selected_entry status) + 1 < (n_entries_viewed status)
        then e_nextentry
        else do with_status_io draw_entries
                cont

-- Text view manipulation

update_scroll :: Entry a => RI a ELCont
update_scroll = do
    with_status_io draw_textarea
    with_status_io draw_botinfo
    cont 

e_vscroll :: Entry a => Int -> RI a ELCont
e_vscroll amount = do
    mod_status $ do_vscroll amount
    update_scroll

e_hscroll :: Entry a => Int -> RI a ELCont
e_hscroll amount = do
    mod_status $ do_hscroll amount
    update_scroll

e_pgdn :: Entry a => RI a ELCont
e_pgdn = do
    n <- with_status (\s -> ((textarea_height s) `div` 2))
    e_vscroll n

e_pgup :: Entry a => RI a ELCont
e_pgup = do
    n <- with_status (\s -> (-(textarea_height s) `div` 2))
    e_vscroll n

e_eob :: Entry a => RI a ELCont
e_eob = do
    mod_status (\s -> s{textarea_vscroll = max_vscroll s})
    update_scroll 

e_bob :: Entry a => RI a ELCont
e_bob = do
    mod_status (\s -> s{textarea_vscroll = 0})
    update_scroll

-- Entry tree manipulation

e_selectentry :: Entry a => Int -> RI a ELCont
e_selectentry n = do
    mod_status (do_selectentry n)
    with_status_io draw_entries
    with_status_io draw_midinfo 
    cont

e_nextentry :: Entry a => RI a ELCont
e_nextentry = do
    n <- with_status (\s -> selected_entry s + 1) 
    e_selectentry n

e_preventry :: Entry a => RI a ELCont
e_preventry = do
    n <- with_status (\s -> selected_entry s - 1)
    e_selectentry n

e_pgdnentry :: Entry a => RI a ELCont
e_pgdnentry = do
    n <- with_status f
    e_selectentry n
    where
        f s = min (n_entries_viewed s - 1) 
                  $ selected_entry s + (entryarea_height s `div` 2)

e_pgupentry :: Entry a => RI a ELCont
e_pgupentry = do
    n <- with_status f
    e_selectentry n
    where
        f s = max 0 $ selected_entry s - (entryarea_height s `div` 2)

e_lastentry :: Entry a => RI a ELCont
e_lastentry = do
    n <- with_status (\s -> n_entries_viewed s - 1)
    e_selectentry n

e_firstentry :: Entry a => RI a ELCont
e_firstentry = e_selectentry 0

e_actentry :: Entry a => RI a ELCont
e_actentry = do
    sel <- with_status selected_entry
    mod_status (do_actentry sel)
    mod_status (\s -> do_expand s sel)
    refresh
    cont

e_delentry :: Entry a => RI a ELCont
e_delentry = do
     n <- with_status selected_entry
     mod_status (\s -> do_delentry s n)
     cont_refresh

e_collapse :: Entry a => RI a ELCont
e_collapse = do
    mod_status (\s -> do_collapse_p s $ selected_entry s)
    cont_refresh

e_editentry :: EditableEntry a => RI a ELCont
e_editentry = do
    sel <- with_status selected_entry
    do_editentry sel

e_newentry :: Entry a => RI a ELCont
e_newentry = do
    loc <- with_status (\s -> case null (entries s) of
                                  True -> First
                                  False -> (After $ selected_entry_loc s))
    do_newentry loc
            
e_newunder :: Entry a => RI a ELCont
e_newunder = do
    loc <- with_status (\s -> case null (entries s) of
                                  True -> First
                                  False -> (FirstUnder (selected_entry_loc s)))
    do_newentry loc

e_undo :: Entry a => RI a ELCont
e_undo = do
    mod_status undo
    cont_refresh
 
e_redo :: Entry a => RI a ELCont
e_redo = do
    mod_status redo
    cont_refresh
    

-- Tags

e_tag :: Entry a => TagAction -> RI a ELCont
e_tag act = do
    mod_status (\s -> do_tag s act (selected_entry s))
    goto_next_or_redraw

e_clear_tags :: Entry a => RI a ELCont
e_clear_tags = do
    mod_status do_clear_tags
    with_status_io draw_entries
    cont

e_move_tagged_after :: Entry a => RI a ELCont
e_move_tagged_after = do
    mod_status (\s -> do_move_tagged s (After $ selected_entry_loc s))
    cont_refresh 

e_move_tagged_before :: Entry a => RI a ELCont
e_move_tagged_before = do
    mod_status (\s -> do_move_tagged s (Before $ selected_entry_loc s))
    cont_refresh 

e_move_tagged_under :: Entry a => RI a ELCont
e_move_tagged_under = do
    mod_status (\s -> do_move_tagged s (FirstUnder $ selected_entry_loc s))
    mod_status (\s -> do_expand s (selected_entry s))
    cont_refresh

e_delete_tagged :: Entry a => RI a ELCont
e_delete_tagged = do
    mod_status (\s -> do_delete s $ entrytree_get_tagged $ entries s)
    cont_refresh

-- Misc.

e_save :: Entry a => RI a ELCont
e_save = do
    save
    with_status_io draw_midinfo
    with_status_io (\s -> message s ("Saved " ++ 
                                     (fromMaybe "???" $  entries_fname s)))
    cont_clr

e_clear_message :: Entry a => RI a ELCont
e_clear_message = do
    with_status_io clear_message
    cont

e_help :: Entry a => RI a ELCont
e_help = do
    km <- gets (cfg_key_map . ri_settings)
    let help_text = concat (intersperse "\n" (KeyMap.gen_help_text km))
    help_km <- gets (cfg_help_key_map . ri_settings)
    mod_status (\s -> s {mode = HelpMode help_text, 
                         active_key_map = help_km})
    cont_refresh
       
e_quit_help :: Entry a => RI a ELCont
e_quit_help = do
    km <- gets (cfg_key_map . ri_settings)
    mod_status (\s -> s {mode = DefaultMode, 
                         active_key_map = km})
    cont_refresh

update_scroll_help :: Entry a => RI a ELCont
update_scroll_help = do
    mode <- gets (mode . ri_status)
    let text = case mode of
                   HelpMode t -> t
                   _ -> ""
    with_status_io (\s -> draw_helparea s text)
    with_status_io (\s -> draw_botinfo_help s text)
    cont 

e_vscroll_help :: Entry a => Int -> RI a ELCont
e_vscroll_help amount = do
    mod_status $ do_vscroll_help amount
    update_scroll_help

e_help_up :: Entry a => RI a ELCont
e_help_up = do
    n <- with_status (\s -> (-(helparea_height s) `div` 2))
    e_vscroll_help n

e_help_down :: Entry a => RI a ELCont
e_help_down = do
    n <- with_status (\s -> ((helparea_height s) `div` 2))
    e_vscroll_help n

get_key_handler ::  EditableEntry a => KeyMap -> Curses.Key -> RI a ELCont
get_key_handler km k = get_key_handler2 [] km k

-- The key list parameter is needed for submaps to be able to display the
-- keys entered so for
get_key_handler2 ::  EditableEntry a => [Curses.Key] -> KeyMap 
                 -> Curses.Key -> RI a ELCont
get_key_handler2 keys  km k = 
    case lookup k km of
      Just (Action _ f) -> f
      Just (TopAction _ _ f) -> f
      Just (Submap km') -> e_submap (keys ++ [k]) km' 
      Nothing           -> e_fallback (keys ++ [k]) km k 

-- }}}


-- Main event loop {{{

getCh :: IO (Maybe Curses.Key)
getCh = do
    v <- Curses.getch
    return $ case v of
        (-1) -> Nothing
        k_ -> Just $ Curses.decodeKey k_

de_elcont :: ELCont -> (Bool, Bool)
de_elcont ELQuit = (False, False)
de_elcont (ELCont ClearNextKey) = (True, True)
de_elcont _ = (True, False)

save_changes :: Entry a => RI a ()
save_changes = do
    uns <- unsaved_changes <@ get_status
    when uns $ do
        ri_catch e_save do_except
	return ()

do_except :: Entry a => Control.Exception.Exception -> RI a ELCont
do_except e = do
    s <- get_status
    liftIO $ Curses.beep
    liftIO $ do_message s attr_error (show e)
    return (ELCont ClearNextKey)

event_loop_ :: EditableEntry a => Bool -> RI a ()
event_loop_ clr = do
    k <- get_key refresh
    with_status_io $ \s -> if clr then clear_message s else return ()
    km <- gets (active_key_map . ri_status)
    (cont, clr) <- liftM de_elcont $
        ri_catch (get_key_handler km k) do_except
    so <- cfg_save_always <@ get_settings
    when so save_changes
    when cont (event_loop_ clr)

event_loop :: EditableEntry a => RI a ()
event_loop = 
    ri_bracket (liftIO $ Curses.cursSet Curses.CursorInvisible)
	       (\_ -> liftIO $ Curses.cursSet Curses.CursorVisible)
               (\_ -> event_loop_ False)

-- }}}

